Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-03/imb9008.zip/PREPROC.BAS

BASIC Source File | 1990-07-12 | 16KB | 495 lines

DECLARE FUNCTION PreAvail87% ()
DECLARE SUB PreDefine (CV AS ANY, DefineTbl$, symbol$)
DECLARE SUB PreElse (CV AS ANY)
DECLARE SUB PreEndIf (CV AS ANY)
DECLARE SUB PreErr (CV AS ANY, S$)
DECLARE FUNCTION PreExist% (FileName$)
DECLARE FUNCTION PreGetDosVer$ ()
DECLARE FUNCTION PreGetEnvDefs$ (Tbl$, Parms AS ANY)
DECLARE SUB PreGetSymbol (L$, C$, S$, O$)
DECLARE SUB PreGetWord (L$, W$())
DECLARE SUB PreIfDefined (CV AS ANY, DefineTbl$, Operand$)
DECLARE SUB PreIfNDefined (CV AS ANY, DefineTbl$, Op$)
DECLARE SUB PreInclude (Op$, DefineTbl$)
DECLARE SUB PreProcessFile (FileIn$, DefineTbl$, IncStatus%)
DECLARE SUB PreProcessLine (CV AS ANY, DefineTbl$)
DECLARE SUB PreSetSysDefs (Tbl$, Parms AS ANY)
DECLARE SUB PreUnDefine (CV AS ANY, DefineTbl$, symbol$)
DECLARE FUNCTION PreValidFile% (FileIn$)
DEFINT A-Z

'BASIC 7.0 Users should change the next line to use
'the QBX.BI include file

'$INCLUDE: 'QB.BI'

'Include the TABLMNGR.BI AND TABLMNGR.BAS files from the
'RAM Tables article

'$INCLUDE: 'TABLMNGR.BI'

    CLS

'Initialize global variables and constants

    CONST True = -1, False = 0

    TYPE PreProcParameters              'Define the parameters
        Sym     AS SymbolTableParameters  '  used for the
        Chr     AS STRING * 2             '  preprocessor
        EnvSym  AS STRING * 7
    END TYPE

    TYPE CurrentLevelValues             'This structure maintains
        FileName      AS STRING * 72      '  the values for the
        FileInNbr     AS INTEGER          '  current level of IF/
        LineNbr       AS INTEGER          '  FILE processing
        PreStatus     AS INTEGER          'Output status before IF
        CurrentStatus AS INTEGER          'Output status inside IF
        IfFound       AS INTEGER          'These three variables
        ElseFound     AS INTEGER          '  track the reading of
        EndIfFound    AS INTEGER          '  these symbols
    END TYPE

    DIM SHARED RegsX AS RegTypeX
    DIM SHARED PreParms AS PreProcParameters

    PreParms.Sym.SWidth = 10      'Maximum symbol width
    PreParms.Sym.Delim = "\"     'Delimiter between symbols in tbl
    PreParms.Chr = "'%"          'Prefix to scan for in BASIC prog
    PreParms.EnvSym = "PREPROC"  'Environment keyword

' Initialize the symbol table

    IF NOT SymCreateTbl(DefineTbl$, PreParms.Sym, 1) THEN
         PRINT "Error - Couldn't allocate symbol table"
         END
    END IF

' Create automatic symbol definitions

    CALL PreSetSysDefs(DefineTbl$, PreParms)
    InclPath$ = PreGetEnvDefs(DefineTbl$, PreParms)

' Begin to process the file now

    FileCmd$ = COMMAND$
    IF LEN(FileCmd$) <> 0 THEN
        FileOut$ = FileCmd$ + ".PRE"
        FileOutNbr = 1
        OPEN FileOut$ FOR OUTPUT AS #FileOutNbr
        CALL PreProcessFile(FileCmd$ + ".BAS", DefineTbl$, False)
        CLOSE
    ELSE
        PRINT "No input file given on command line"
    END IF
    PRINT "Program terminated."
    END

'----------------------------------------------------------------

'----------------------------------------------------------------
'  Call an interrupt to check on
'  math coprocessor availability
'----------------------------------------------------------------
FUNCTION PreAvail87
    RegsX.ax = 0
    CALL INTERRUPTX(&H11, RegsX, RegsX)
    IF RegsX.ax AND 2 THEN
        PreAvail87 = True
    ELSE
        PreAvail87 = False
    END IF
END FUNCTION

'----------------------------------------------------------------
'Define a symbol for the preprocessor by calling a TABLMNGR Func
'----------------------------------------------------------------
SUB PreDefine (CV AS CurrentLevelValues, DefineTbl$, symbol$)
    IF NOT SymDefine(DefineTbl$, symbol$, PreParms.Sym) THEN
        PRINT CV.FileName; CV.LineNbr;
        PRINT "Warning - " + symbol$ + " duplicate definition"
        PRINT "or symbol contains the table delimiter character ";
        PRINT PreParms.Sym.Delim
    END IF
END SUB

'----------------------------------------------------------------
'Manage the preprocessor ELSE tasks
'  PreElse checks for duplicate ELSE's and ELSE's without IF's
'----------------------------------------------------------------
SUB PreElse (CV AS CurrentLevelValues)
    IF CV.IfFound THEN
        IF CV.ElseFound THEN
            CALL PreErr(CV, "Duplicate Else Found")
        ELSE
            ElseFound = True
            IF CV.PreStatus THEN
                CV.CurrentStatus = NOT CV.CurrentStatus 'Swap ELSE status
            ELSE
                CV.CurrentStatus = False 'Must be outputting outside IF
            END IF                     '  for us to start ouputting now
        END IF
    ELSE
        CALL PreErr(CV, "ELSE found without an IF statement")
    END IF
END SUB

'----------------------------------------------------------------
'Manage the preprocessor ENDIF tasks
'----------------------------------------------------------------
SUB PreEndIf (CV AS CurrentLevelValues)
    IF CV.IfFound THEN
        CV.EndIfFound = True
        IfFound = False     'Set this so you end the current IF level
    ELSE
        PreErr CV, "ENDIF without IF found"
    END IF
END SUB

'----------------------------------------------------------------
'Print error messages to screen
'----------------------------------------------------------------
SUB PreErr (CV AS CurrentLevelValues, S$)
    PRINT "+ "; RTRIM$(CV.FileName); " Line #: "; CV.LineNbr;
    PRINT "Preprocessor ERROR-"; S$
END SUB

'----------------------------------------------------------------
' See if a given file exists using
' DOS "Search for first match" service &H4E
'----------------------------------------------------------------
FUNCTION PreExist% (FileName$)

    RegsX.ax = &H4E00
    RegsX.cx = 63  ' Search for all files

    Spec$ = FileName$ + CHR$(0)

'BASIC 7.0 Users should change all occurences of
'VARSEG to SSEG (there's only one VARSEG in this program)

    RegsX.ds = VARSEG(Spec$) ' Load DS:DX with
    RegsX.dx = SADD(Spec$) ' address of Spec$

    CALL INTERRUPTX(&H21, RegsX, RegsX) ' CALL DOS

' If AX contains a value, then file does not exist

    SELECT CASE RegsX.ax
        CASE 0
            PreExist% = True
        CASE ELSE
            PreExist% = False
    END SELECT

END FUNCTION

'----------------------------------------------------------------
'Calls interrupt &H21, function &H30 to create a symbol for the
'  current DOS version
'----------------------------------------------------------------
FUNCTION PreGetDosVer$
    RegsX.ax = &H3000
    CALL INTERRUPTX(&H21, RegsX, RegsX)
    MajorVersion = RegsX.ax MOD 256
    MinorVersion = RegsX.ax \ 256
    DosV$ = "DOS" + RIGHT$(STR$(MajorVersion), 1)
    PreGetDosVer$ = DosV$ + RIGHT$(STR$(MinorVersion), 2)
END FUNCTION

'----------------------------------------------------------------
'Retrieve the symbols you define as part of your environment
'  using the value you store Parms.EnvSym.  Also retrieves the
'  INCLUDE environment variable if it exists.
'----------------------------------------------------------------
FUNCTION PreGetEnvDefs$ (Tbl$, Parms AS PreProcParameters)

    LenEnvSym = LEN(Parms.EnvSym)
    EnvLine = 1
    IPath$ = ""                 'Initialize the include paths value

    DO     'Loop until find both values looking for or end of table

        Env$ = ENVIRON$(EnvLine)

        IF LEFT$(Env$, LenEnvSym) = Parms.EnvSym THEN

            BegDefPos = INSTR(Env$, "=") + 1

            DO UNTIL BegDefPos > LEN(Env$)
                EndDefPos = INSTR(BegDefPos, Env$, ";")
                IF EndDefPos = 0 THEN EndDefPos = LEN(Env$) + 1
                EnvSym$ = MID$(Env$, BegDefPos, EndDefPos - BegDefPos)
                IF NOT SymDefine(Tbl$, EnvSym$, Parms.Sym) THEN
                    PRINT "Unable to define "; EnvSym$; " from environment"
                END IF
                BegDefPos = EndDefPos + 1
            LOOP

            FoundPP = True                 'Sets one of the found flags

        ELSEIF LEFT$(Env$, 7) = "INCLUDE" THEN

            IPath$ = MID$(Env$, 9)
            FoundInclude = True            'Sets one of the found flags

        END IF

        IF FoundPP AND FoundInclude THEN EXIT DO
        EnvLine = EnvLine + 1
        Env$ = ENVIRON$(EnvLine)

    LOOP WHILE LEN(Env$)

    PreGetEnvDefs$ = IPath$

END FUNCTION

'----------------------------------------------------------------
'Gets the first two symbols from the input line
'  Checks to see if the first one matches the preprocessor prefix
'  symbols.  If it matches, set symbol and operand values
'----------------------------------------------------------------
SUB PreGetSymbol (L$, C$, S$, O$)

    DIM Word$(2)
    L$ = UCASE$(LTRIM$(RTRIM$(L$)))
    C$ = "IGNORE"    'Ignore non-commands
    S$ = ""
    O$ = ""
    IF LEN(L$) <> 0 THEN
        PreGetWord (L$), Word$()
        Prefix$ = LEFT$(Word$(1), 2)
        IF Prefix$ = PreParms.Chr OR Prefix$ = "'$" THEN
            C$ = "PreProc"
            S$ = MID$(Word$(1), 3)
            O$ = Word$(2)
        END IF
    END IF
END SUB

'----------------------------------------------------------------
'Loop through a line to retrieve the individual words delimited
'  by spaces.
'----------------------------------------------------------------
SUB PreGetWord (L$, W$())
    Delim$ = " "
    BegPos = 1
    LenL = LEN(L$)
    FOR I% = 1 TO 2                         'Get only first 2 words
        DelimPos = INSTR(BegPos, L$, Delim$)
        IF DelimPos = 0 THEN DelimPos = LenL + 1
        W$(I%) = MID$(L$, BegPos, DelimPos - BegPos)
        BegPos = DelimPos + 1
        IF BegPos > LenL THEN EXIT FOR
    NEXT I%
END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing IfDefined command.
'----------------------------------------------------------------
SUB PreIfDefined (CV AS CurrentLevelValues, DefineTbl$, Operand$)

    DIM NewCV AS CurrentLevelValues    'Create a new copy of record
                                                                         '  To manage a new IF level
    NewCV.FileName = CV.FileName
    NewCV.FileInNbr = CV.FileInNbr
    NewCV.LineNbr = CV.LineNbr
    NewCV.PreStatus = CV.CurrentStatus
    NewCV.IfFound = True
    NewCV.ElseFound = False
    NewCV.EndIfFound = False

'Set output status to true if currently outputting and condition
'  is true, otherwise set current output status to false

    IF CV.CurrentStatus THEN
        IF SymDefined(DefineTbl$, Operand$, PreParms.Sym) THEN
            NewCV.CurrentStatus = True
        ELSE
            NewCV.CurrentStatus = False
        END IF
    ELSE
        NewCV.CurrentStatus = False
    END IF

'Recursively call a new copy of the PreProcessLine routine

    DO WHILE NOT EOF(NewCV.FileInNbr) AND (NOT NewCV.EndIfFound)
        CALL PreProcessLine(NewCV, DefineTbl$)
    LOOP
    CV.LineNbr = NewCV.LineNbr
END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing IfNDefined command.
'----------------------------------------------------------------
SUB PreIfNDefined (CV AS CurrentLevelValues, DefineTbl$, Op$)

    DIM NewCV AS CurrentLevelValues    'Create a new copy of record
                                                                         '  to manage a new IF level
    NewCV.FileName = CV.FileName
    NewCV.FileInNbr = CV.FileInNbr
    NewCV.LineNbr = CV.LineNbr
    NewCV.PreStatus = CV.CurrentStatus
    NewCV.IfFound = True
    NewCV.ElseFound = False
    NewCV.EndIfFound = False

'Set output status to true if currently outputting and condition
'  is true, otherwise set current output status to false

    IF CV.CurrentStatus THEN
        IF (NOT SymDefined(DefineTbl$, Op$, PreParms.Sym)) THEN
            NewCV.CurrentStatus = True
        ELSE
            NewCV.CurrentStatus = False
        END IF
    ELSE
        NewCV.CurrentStatus = False
    END IF

    DO WHILE NOT EOF(NewCV.FileInNbr) AND (NOT NewCV.EndIfFound)
        CALL PreProcessLine(NewCV, DefineTbl$)
    LOOP
    CV.LineNbr = NewCV.LineNbr

END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing Include command
'  Add lines from Include file into output file so include files
'  can have preprocessing lines also
'----------------------------------------------------------------
SUB PreInclude (Op$, DefineTbl$)
    Op$ = MID$(Op$, 2, LEN(Op$) - 2)
    CALL PreProcessFile(Op$, DefineTbl$, True) 'New copy of routine
END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing File command.
'----------------------------------------------------------------
SUB PreProcessFile (FileIn$, DefineTbl$, IncStatus)
    DIM CV AS CurrentLevelValues 'Create a new record for new level
    SELECT CASE PreValidFile(FileIn$)        'Make sure file exists
        CASE 0
            CV.FileName = FileIn$
            CV.FileInNbr = FREEFILE              'Get new valid number
            CV.LineNbr = 0
            CV.CurrentStatus = True
            CV.PreStatus = True
            CV.IfFound = False
            CV.ElseFound = False
            CV.EndIfFound = False
            OPEN CV.FileName FOR INPUT AS #CV.FileInNbr
            DO WHILE NOT EOF(CV.FileInNbr)
                PreProcessLine CV, DefineTbl$      'Invoke new copy
            LOOP
            CLOSE CV.FileInNbr
        CASE 1
            PRINT "Can't find file->"; FileIn$ 'If can't file including
            IF IncStatus THEN                  '  keep line in file
                PRINT #1, "'$INCLUDE: '" + FileIn$ + "'"
            END IF
        CASE 2
            PRINT CV.FileName;
            PRINT "<-Invalid format - may be BASIC fast save format"
    END SELECT
END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing Line command.
'----------------------------------------------------------------
SUB PreProcessLine (CV AS CurrentLevelValues, DefineTbl$)
    LINE INPUT #CV.FileInNbr, LineIn$

    DO
        CV.LineNbr = CV.LineNbr + 1
        CALL PreGetSymbol((LineIn$), Class$, symbol$, Op$)
        IF Class$ <> "PreProc" THEN
            IF CV.CurrentStatus THEN
                PRINT #1, LineIn$
            END IF
        ELSE
            SELECT CASE symbol$   'Split CASE into cmds that require
                CASE "ELSE"         '  operands and those who don't
                    CALL PreElse(CV)
                CASE "ENDIF"
                    CALL PreEndIf(CV)
                    IF CV.EndIfFound THEN EXIT SUB
                CASE ELSE                'These commands require operands
                    IF Op$ <> "" THEN
                        SELECT CASE symbol$
                            CASE "DEFINE"
                                IF CV.CurrentStatus THEN
                                    CALL PreDefine(CV, DefineTbl$, Op$)
                                END IF
                            CASE "UNDEFINE"
                                IF CV.CurrentStatus THEN
                                    CALL PreUnDefine(CV, DefineTbl$, Op$)
                                END IF
                            CASE "IFDEFINED"
                                CALL PreIfDefined(CV, DefineTbl$, Op$)
                            CASE "IFNDEFINED"
                                CALL PreIfNDefined(CV, DefineTbl$, Op$)
                            CASE "INCLUDE:"
                                IF CV.CurrentStatus THEN
                                    CALL PreInclude(Op$, DefineTbl$)
                                END IF
                            CASE ELSE
                                PRINT #1, "'Invalid Preprocessing command: ";
                                PRINT #1, LineIn$
                        END SELECT
                    ELSE
                        PRINT #1, "'Missing operand for "; symbol$;
                        PRINT #1, " preprocessing command"
                    END IF
            END SELECT
        END IF
        IF NOT (EOF(CV.FileInNbr)) THEN
            LINE INPUT #CV.FileInNbr, LineIn$
        END IF
    LOOP UNTIL EOF(CV.FileInNbr)
END SUB

'----------------------------------------------------------------
'Set the automatic system symbols
'----------------------------------------------------------------
SUB PreSetSysDefs (Tbl$, Parms AS PreProcParameters)
    IF PreAvail87 THEN   'Add Coprocessor to table if available
        Dummy = SymDefine(Tbl$, "AVAIL87", Parms.Sym)
    END IF
    Dummy = SymDefine(Tbl$, PreGetDosVer$, Parms.Sym)
END SUB

'----------------------------------------------------------------
'Manage tasks for Preprocessing UnDefine command.
'----------------------------------------------------------------
SUB PreUnDefine (CV AS CurrentLevelValues, DefineTbl$, symbol$)
    IF NOT SymUnDefine(DefineTbl$, symbol$, PreParms.Sym) THEN
        PRINT CV.FileName; CV.LineNbr;
        PRINT "Warning - " + symbol$ + " tried to undefine"
        PRINT "non-existent symbol or symbol contains the table"
        PRINT "delimiter character "; PreParms.Sym.Delim
    END IF
END SUB

'----------------------------------------------------------------
'Make sure the file exists and check first byte to see if TXT fmt
'  which seems to be &HFC for BASIC quick save format
'----------------------------------------------------------------
FUNCTION PreValidFile (FileIn$)
    PreValidFile = 0
    IF NOT PreExist(FileIn$) THEN
        PreValidFile = 1
    ELSE
        TestNbr = FREEFILE
        OPEN FileIn$ FOR BINARY AS TestNbr
        TestByte$ = " ": GET TestNbr, 1, TestByte$
        CLOSE TestNbr
        IF TestByte$ = CHR$(&HFC) THEN PreValidFile = 2
    END IF
END FUNCTION